perm filename MOV.F4[NEW,LCS] blob
sn#148538 filedate 1975-03-04 generic text, type T, neo UTF8
00100 C****** MOVER, MVBEAM, MVBX, RTLINE, EXTEN, CLEFS
00200 SUBROUTINE MOVER
00800 COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
00810 1 /XRN/RN(4000) /KJY/ K,JY /STF/RSTFAC(-3/4),RSTJ2
00855 1 /FRMT/F78F(1),FA1(1),FA5(1),ASK
00900 COMMON/POSI/STFF(-3/4),JJ2,POS/PTR/PWDS(250),ITEM,LL,I,IX
00910 COMMON/ALF/INP(47),ML,RRT,RZRO,RCNT,RJSZ,ROV,RSPC,KN,RA,RB,
00920 1 JLDGR,LDGR,JX,RW,RX,RY,RZ,JJ,RD,RQ,RE,RZZ,RN3,RN6,RV,RQ6
01000 EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
01100 1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7)),(R11,RJQ(9))
01400
01500 JJ2=-1
01700 J2=0
01800 C 99=BACKUP
01900 6 CALL VLINE(R2,R4,R5,R6)
02000 IF(R2.GE.99)RETURN
02100 IF(INP(1).NE.'J')GO TO 12
02110 M=4
02120 ML=0
02200 RRT=R5
02300 RZRO=R4
02400 IF(RRT.EQ.0)RRT=200
02500 IF(RZRO.EQ.0)RZRO=.001
02510 R7=R2
02540 R6=0
02570 R11=0
02800 16 CALL MOVJ(ROV,RZRO,RRT,RSTFAC,RN,PWDS,ITEM,I,ML,M)
18200 R4=RZRO
18300 R5=ROV
18400 R8=RZRO
18500 R9=RRT-.001
18600 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
18700 ML=2
18900 GO TO 66
19000 18 ML=3
19100 R8=RRT-ROV
19200 CC R9=RRT+2
19250 R9=0
19300 C GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
19400 R4=RRT
19500 R5=1000
19600 166 JJ2=-1
19700 J2=0
19710 266 IF(RCNT.EQ.1)RVX=ROV+2
19755 C RVX SHOULD BE FARTHEST POINT TO RIGHT.
19800 GO TO 66
19850 1200 FORMAT(' MOVED TO STAFF ',F4.0/)
19860 C****** BEGIN MOVER *******
19900 12 TYPE 5
20000 ML=4
20100 ACCEPT F78F,R7,R8,R9,R11
20110 RDIS=0
20200 REREAD FA1,L
20300 C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
20305 IF(R2.NE.88)GO TO 167
20320 C 88, 1ST ITEM, LAST ITEM: STAFF N, MOVE HOR., MOVE VERT.
20330 LDGR=R5
20335 J2=R4-1
20340 C 1ST ITEM.
20345 R4=-500
20350 R5=500
20355 L=I
20357 C ↑↑↑↑ FOR 'C'OPY
20360 168 IF(J2.GT.LDGR)GO TO 101
20365 JY=PWDS(J2+1)
20367 IF(INP(1).NE.'C')L=JY
20370 GO TO 6551
20375
20400 167 IF(R7.GE.99)GO TO 6
20410 IF(R7.NE.R2)TYPE 1200,R7
20420 IF(R2.GT.4)R7=R2
20500 IF(L.NE.'L')GO TO 66
20600 DO 67 K=1,2
20700 R8=RY
20800 CALL LPEN(R7,RY,RX)
20900 67 IF(R7.GE.99)GO TO 6
21000 R9=RY
21010
21100 66 JY=1
21200 L=JY
21300 IF(INP(1).EQ.'C')L=I
21400 C C=COPY
21600 IF(R9.NE.0)RDIS=(R9-R8)/(R5-R4)
21700
21800 6551 CALL MOVR(ML,J2,JJ2,JY,L,INP(1),RN,PWDS,R4,ITEM,I)
29000 GO TO (16,18,101,1),ML
29100 101 JJ2=1
29200 1 CALL HYDPOG(3)
29300 5 FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN # '$)
29400 END
29500
29510 SUBROUTINE TYPX(R)
29520 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
29530 DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/
29540 TYPE F78F,R
29550 END
29560
29600 FUNCTION RTLINE(L)
29700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
29800 RTLINE=-1
29900 IF(R2.GT.4)GO TO 1
29910 IF(RN(L+2).NE.R2)RETURN
29920 1 RTLINE=0
30000 END
30100
30200 CC FUNCTION EXTEN(X)
30300 CC EXTEN=AMOD(X,1.)*10.
30400 CC END
30500
30550 C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
30600 SUBROUTINE MVBEAM(R,I,JY,L,W)
30650 C L AND JY ARE FOR MOVES TO DIFF. STAFF.
30700 DIMENSION R(1)
30710 Y=R(JY+I)
30720 Z=ABS(Y)
30730 IF(Z.LT.100.)GO TO 1
30740 C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
30750 Y=AMOD(Y,100.)
30755 X=Y+W
30760 Z=Z-ABS(Y)+ABS(X)
30770 C PUTS ALL INTO POSITIVE
30780 IF(X)Z=-Z
30790 GO TO 2
30795 1 Z=Y+W
30800 2 R(L+I)=Z
30900 END
31000
31100 SUBROUTINE MVBX(I)
31110 COMMON R2,JA,CENTR,J2,RJQ(20),L,RDIS,JQ(18)/KJY/K,JY/XRN/R(4000)
31210 EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6))
31300 R(L+I)=R8+(R(JY+I)-R4)*RDIS
31400 END
31500
31600 SUBROUTINE CLEFS
31700 DIMENSION JCLEF(11),MCLEF(700),RCMIN(4),KCLEF(11),NCLEF(350),CM(4)
31800 COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
31900 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
32000 DATA RCMIN/3.3,10.5,7.0,10.5/,CM/.1,1.5,1.1,1.5/
32100 EQUIVALENCE (R4,RJQ(2)),(J5,JQ(3)),(J9,JQ(7)),(KK,
32200 1 KCLEF(11)),(R6,RJQ(4)),(R5,RJQ(3)),(R8,RJQ(6)),(R7,RJQ(5))
32300 1,(R9,RJQ(7)),(NJR,RJQ(8)),(K,JCLEF(11)),(NCLEF,MCLEF(351))
32350 1,(R3,RJQ(1))
32400 J5=MOD(J5,100)
32600 CALL NOZERO(R6)
32700 IF(R7.EQ.0)R7=R6
32800 C IF P7 = 0, IT WILL EQUAL P6.
32900 IF(JA.GT.10)GO TO 9
33000 NAME='CLEF0'
33100 IF(J5.LT.20)GO TO 4
33200 R6=R6*.3
33300 C SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
33400 R7=R7*.3
33500 GO TO 4
33600 9 IF(NAME.EQ.NJR)GO TO 4
33700 IF(NAME.EQ.0)GO TO 177
33710 IF(NJR.EQ.0)GO TO 4
33800 177 IF(NJR.EQ.0)GO TO 8
33900 C TO PICK UP BASIC DRAW NAME FROM P10
34000 NAME=NJR
34100 GO TO 4
34200 8 TYPE 5
34300 5 FORMAT(' SET P10=1'/)
34400 C LEADS TO PROPER FILE CALL
34500 4 NM=NAME+2*(J5/10)
34600 C DRAW0 HAS ITEMS 0→9; DRAW1, 10→19; ETC. TO DRAW9, 90→99
34700 JEZ=MOD(J5,10)+1
34800 2 IF(NM.EQ.JNM)GO TO 30
34810 IF(NM.EQ.KNM)GO TO 30
34900 C SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
35000 C JUMP IF ALREADY IN CORE
35100 IF(LOOKF(NM))GO TO 1111
35200 TYPE 1112,NM
35300 RETURN
35400 1112 FORMAT(1XA5,' -- NOT FOUND')
35500 1111 CALL GETFI2(NM)
35600 IF(KX)GO TO 33
35700 KX=-1
35800 JNM=NM
36200 CALL FASTI2(JCLEF,11)
36300 CALL FASTI2(MCLEF,K)
36400 C NEW DATA READER 6/74 -- 10/74 HOLDS 2 .DMD FILES IF THEY FIT.
36500 IF(K.LE.350)GO TO 30
36600 KX=0
36700 KNM=0
36800 GO TO 30
36900 33 CALL FASTI2(KCLEF,11)
37000 KX=0
37100 IF(KK.GT.350)GO TO 1111
37200 C JUMP BACK IF IT WON'T FIT.
37300 CALL FASTI2(NCLEF,KK)
37400 KNM=NM
37600 C CHECK THE ABOVE -- FOR P5 HEIGHT CHANGE *********************
37700 C R6 IS SIZE FACTOR
37800 30 IF(J5.GT.3)GO TO 811
37810 IF(JA.NE.3)GO TO 811
37900 C 0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP)
38100 C ↑↑↑↑↑↑↑↑ FIXUP SOMEDAY IN .DMD FILES
38200 IF(R5.LT.100)GO TO 812
38300 RSTJ2=.8*RSTJ2
38500 C TO SET HGT. OF MINI CLEFS
38510 R4=R4+CM(JEZ)
38520 C SHIFTS MINIS UP BECAUSE OF WRONG ORIG. POS.??
38600 812 IF(JEZ.NE.4)GO TO 811
38800 R4=R4+2
38900 JEZ=3
39000 C ABOVE IS NOW AT TOP
39100
39200 811 A=R4
39300 R4=A+2.9
39400 CALL CENTX
39500 R4=A
39600
39800 L=JCLEF(JEZ)
39900 IF(NM.EQ.KNM)L=KCLEF(JEZ)+350
40000 IF(J9.EQ.0)GO TO 31
40100 CALL ROTATE(MCLEF,L)
40200 C R9=P9=DEGREES OF ROTATION (0-360)
40300 IF(KK.GT.250)KX=0
40400 C CHECK TO SEE IF DATA WAS WIPED OUT.
40500 31 IF(R8.EQ.-2)GO TO 32
40505 IF(IPLT)GO TO 77
40510 IF(R8.NE.-1)GO TO 32
40600 C R8=-2 OMITS FILLER DURING PLOT
40700 77 DO 3 K=L+1,MCLEF(L)+L
40800 IF(MCLEF(K).LT.200000000)GO TO 3
40900 JEZ=MCLEF(L)-1
41000 IF(K.GT.L+1)JEZ=JEZ-K+L+1
41100 CALL FILLMS(JEZ,MCLEF(K),R3,CENTR,R6,R7)
41105 GO TO 32
41110 3 CONTINUE
41155 C FILLS ONLY WHEN PLOTING OR R8=-1
41200 32 CALL JDRAW(MCLEF(L),R3,CENTR,RSTJ2,R6,R7)
41300 C 3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, R8=-1 TO FILL ON CRT
41400
41800 END